Delphi 2 - Developers' Solutions/Delphi 2 Developers' Solutions.iso/dds/chap06/howto05/delphi10/drwsutl6.pas

Pascal/Delphi Source File | 1996-01-09 | 12.6 KB | 376 lines

unit Drwsutl6;

interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI, FileCtrl;

type

  File_BitMap = class( TObject )
  public
    Bitmap_Handle    : HBitmap;   { Holds the DIB when done               }
    Width            : Longint;   { Holds the pixel width when done       }
    Height           : Longint;   { Holds the pixel height when done      }
    The_File         : File;      { File variable for internal use        }
    The_Name         : String;    { Holds the file name                   }
    Bits_Handle      : THandle;   { temporary holder for the DIB          }
    Bits_Byte_Size   : Longint;   { temporary holder for the              }
                                  { byte length of the DIB                }
    Error_Status     : Integer;   { code for error condition on the DIB   }

    constructor Create;
    procedure Initialize( The_DIB_Name : String );
    destructor Destroy;
    procedure Get_Bitmap_Data;
    function Get_Bitmap : HBitmap;
    function Load_Bitmap_File : Boolean;
    function Open_DIB : Boolean;
    function Get_Error_Status : Integer;
    procedure Get_DIB_Dimensions( var The_Width  ,
                                      The_Height   : Longint );
  end;

function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
                                          TargetWidth ,
                                          TargetHeight : Integer ) : TBitmap;

implementation

procedure AHIncr; FAR; EXTERNAL 'KERNEL' INDEX 114;

function CreateBitmapThumbNailFromBitmap( SourceBMP: TBitmap;
                                          TargetWidth ,
                                          TargetHeight : Integer ) : TBitmap;
var OutputBMP : TBitmap;
    HoldingBMP : TBitmap;
    TotalSourceColsPerOutputCol,
    TotalSourceRowsPerOutputRow,
    Counter_1 ,
    Counter_2 ,
    Counter_3 : Integer;
    CurrentColor : Longint;
    CurrentRowPointer,
    CurrentColPointer,
    BestLineSoFar ,
    TotalColorsInWork : Integer;
    MaxColorsSoFar    : Integer;
begin
  { if source smaller than or equal to thumbnail, stretchdraw and leave }
  if (( SourceBMP.Width <= TargetWidth ) and
      ( SourceBMP.Height <= TargetHeight )) then
  begin
    OutputBMP := TBitmap.Create;
    OutputBMP.Height := TargetHeight;
    OutputBMP.Width := TargetWidth;
    OutputBMP.Canvas.StretchDraw( Rect( 0 , 0 , TargetWidth , TargetHeight ) ,
     SourceBMP );
    CreateBitmapThumbNailFromBitmap := OutputBMP;
    exit;
  end;
  { Otherwise do thumbnail algorithm }
  { Create the interim holding bitmap; it will hold full width but resized # rows }
  HoldingBMP := TBitmap.Create;
  HoldingBMP.Width := SourceBMP.Width;
  HoldingBMP.Height := TargetHeight;
  { Create the final output bitmap; it will hold the resized values in both h & w }
  OutputBMP := TBitmap.Create;
  OutputBMP.Width := TargetWidth;
  OutputBMP.Height := TargetHeight;
  { Determine the total source rows and cols per output row and col }
  TotalSourceRowsPerOutputRow := ( SourceBMP.Height div TargetHeight );
  if ( SourceBMP.Height mod TargetHeight ) <> 0 then
   Inc( TotalSourceRowsPerOutputRow );
  TotalSourceColsPerOutputCol := ( SourceBMP.Width div TargetWidth );
  if ( SourceBMP.Width mod TargetWidth ) <> 0 then
   Inc( TotalSourceColsPerOutputCol );
  { Start resizing by setting initial row pointer }
  CurrentRowPointer := 0;
  { Loop through desired number of output rows                       }
  { Result will add row per group with highest color density to dest }
  for Counter_1 := 1 to TargetHeight do
  begin
    { Reset colors per line, best cols per line, and best line pointers }
    { Check all the lines in a group against each other }
    TotalColorsInWork := 0;
    MaxColorsSoFar := 0;
    BestLineSoFar := 0;
    for Counter_2 := 1 to TotalSourceRowsPerOutputRow do
    begin
      { Keep moving down the image }
      Inc( CurrentRowPointer );
      if CurrentRowPointer > SourceBMP.Height then break;
      { Start with no color }
      CurrentColor := -1;
      TotalColorsInWork := 0;
      { Actually scan the pixels }
      for Counter_3 := 1 to SourceBMP.Width do
      begin
        { if the current pixel value is different than the stored one }
        If SourceBMP.Canvas.Pixels[ Counter_3 - 1 , CurrentRowPointer - 1 ] <>
         CurrentColor then
        begin
          { Make the new color the stored one }
          CurrentColor := SourceBMP.Canvas.Pixels[ Counter_3 - 1 ,
           CurrentRowPointer - 1 ];
          { Increment total colors in the line }
          Inc( TotalColorsInWork );
        end;
      end;
      { At the end of the line, if there are more colors in the }
      { current line than the previous best line, then }
      if TotalColorsInWork > MaxColorsSoFar then
      begin
        { Set the new max to the current value }
        MaxColorsSoFar := TotalColorsInWork;
        { Set the new best line to the current pointer }
        BestLineSoFar := CurrentRowPointer;
      end;
      { Reset the total colors being checked }
      TotalColorsInWork := 0;
    end;
    MaxColorsSoFar := 0;
    { Once best line is determined, copy all its pixels to the holding bmp }
    for Counter_3 := 1 to SourceBMP.Width do
    begin
      HoldingBMP.Canvas.Pixels[ Counter_3 - 1 , Counter_1 - 1 ] :=
       SourceBMP.Canvas.Pixels[ Counter_3 - 1 , BestLineSoFar - 1 ];
    end;
  end;
  { Then resize by setting initial col pointer }
  CurrentColPointer := 0;
  { Loop through desired number of output cols                       }
  { Result will add col per group with highest color density to dest }
  for Counter_1 := 1 to TargetWidth do
  begin
    { Reset colors per line, best cols per line, and best line pointers }
    TotalColorsInWork := 0;
    MaxColorsSoFar := 0;
    BestLineSoFar := 0;
    { Check all the lines in a group against each other }
    for Counter_2 := 1 to TotalSourceColsPerOutputCol do
    begin
      { Keep moving down the image }
      Inc( CurrentColPointer );
      if CurrentColPointer > HoldingBMP.Width then break;
      { Start with no color }
      CurrentColor := -1;
      { Actually scan the pixels }
      for Counter_3 := 1 to HoldingBMP.Height do
      begin
        { if the current pixel value is different than the stored one }
        If HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 , Counter_3 - 1 ] <>
         CurrentColor then
        begin
          { Make the new color the stored one }
          CurrentColor := HoldingBMP.Canvas.Pixels[ CurrentColPointer - 1 ,
           Counter_3 - 1 ];
          { Increment total colors in the line }
          Inc( TotalColorsInWork );
        end;
      end;
      { At the end of the line, if there are more colors in the }
      { current line than the previous best line, then }
      if TotalColorsInWork > MaxColorsSoFar then
      begin
        { Set the new max to the current value }
        MaxColorsSoFar := TotalColorsInWork;
        { Set the new best line to the current pointer }
        BestLineSoFar := CurrentColPointer;
      end;
      { Reset the total colors being checked }
      TotalColorsInWork := 0;
    end;
    { Once best line is determined, copy all its pixels to the holding bmp }
    for Counter_3 := 1 to HoldingBMP.Height do
    begin
      OutputBMP.Canvas.Pixels[ Counter_1 - 1 , Counter_3 - 1 ] :=
       HoldingBMP.Canvas.Pixels[ BestLineSoFar - 1 , Counter_3 - 1 ];
    end;
  end;
  { Finally, output the thumbnail image }
  CreateBitmapThumbNailFromBitmap := OutputBMP;
  { And free the working copy }
  HoldingBMP.Free;
end;

{ This creates a file bitmap object }
constructor File_BitMap.Create;
begin
  { call inherited FIRST! }
  inherited Create;
  { Zero out the data elements }
  Bitmap_Handle := 0;
  The_Name := '';
end;

{ This procedure sets up the bitmap filename to load }
procedure File_BitMap.Initialize( The_DIB_Name : String );
begin
  The_Name := The_DIB_Name;
end;

{ This is the destructor procedure }
destructor File_BitMap.Destroy;
begin
  { Assume bitmap handle given to TBitmap and cleared there }
  { call inherited last }
  inherited destroy;
end;

{ This method copies the bitmap bits data from the file into memory. Since }
{ copying cannot cross a segment (64K) boundary, segment arithmetic must   }
{ be done on the fly.  A LongType type was created to simplify this process}
procedure File_BitMap.Get_Bitmap_Data;

type
  LongType = record
  case Word of
    0: ( Ptr  : Pointer );
    1: ( Long : Longint );
    2: ( Lo   : Word;
         Hi   : Word    );
  end;
var
  Count   : Longint;
  Start,
  ToAddr,
  Bits    : LongType;
begin
  Start.Long := 0;
  Bits.Ptr := GlobalLock( Bits_Handle );
  Count := Bits_Byte_Size - Start.Long;
  while Count > 0 do
  begin
    ToAddr.Hi := Bits.Hi + ( Start.Hi * OFS( AHIncr ));
    ToAddr.Lo := Start.Lo;
    if Count > $4000 then Count := $4000;
    BlockRead( The_File , ToAddr.Ptr^ , Count );
    Start.Long := Start.Long + Count;
    Count := Bits_Byte_Size - Start.Long;
  end;
  GlobalUnlock( Bits_Handle );
end;

{ This returns the handle to the stored bitmap }
function File_BitMap.Get_Bitmap : HBitmap;
begin
  Get_Bitmap := Bitmap_Handle;
end;

{ This is the function to call to load a bitmap file of any size }
{ If no errors occur it returns true, otherwise false; use GEC   }
{ (Some portions of this code are copyright Borland Intl, 1990.) }
function File_BitMap.Load_Bitmap_File : Boolean;
var
  Test_Win30_Bitmap : Longint;
  Memory_DC         : HDC;
  The_IO_Result     : Word;
begin
  Error_Status := 0;
  Load_Bitmap_File := false;
  AssignFile( The_File , The_Name );
  {$I-}
  Reset( The_File , 1 );
  Seek( The_File , 14 );
  BlockRead( The_File , Test_Win30_Bitmap , SizeOf( Test_Win30_Bitmap ));
  {$I+}
  The_IO_Result := IOResult;
  If The_IO_Result <> 0 then
  begin
    Error_Status := -1;
  end
  else
  begin
    if Test_Win30_Bitmap = 40 then
    begin
      if Open_DIB then
      begin
        Load_Bitmap_File := true;
      end;
    end
    else
    begin
      Error_Status := -2;
    end;
    CloseFile( The_File );
  end;
end;

{ This does the actual loading of the bitmap's info }
function File_BitMap.Open_DIB : Boolean;
var
  Bit_Count         : Word;
  Size              : Word;
  Long_Width        : Longint;
  DC_Handle         : HDC;
  Bits_Ptr          : Pointer;
  Bitmap_Info       : PBitmapInfo;
  New_Bitmap_Handle : THandle;
  New_Pixel_Width,
  New_Pixel_Height  : Word;
begin
  Open_DIB := true;
  Seek( The_File , 28 );
  BlockRead( The_File , Bit_Count , SizeOf( Bit_Count ));
  if Bit_Count <= 8 then
  begin
    Size := SizeOf( TBitmapInfoHeader ) + (( 1 SHL Bit_Count )
     * SizeOf( TRGBQuad ));
    Bitmap_Info := MemAlloc( Size );
    Seek( The_File , SizeOf( TBitmapFileHeader ));
    BlockRead( The_File , Bitmap_Info^ , Size );
    New_Pixel_Width := Bitmap_Info^.bmiHeader.biWidth;
    New_Pixel_Height := Bitmap_Info^.bmiHeader.biHeight;
    Long_Width := ((( New_Pixel_Width * Bit_Count ) + 31 ) div 32 ) * 4;
    Bitmap_Info^.bmiHeader.biSizeImage := Long_Width * New_Pixel_Height;
    GlobalCompact( -1 );
    Bits_Handle := GlobalAlloc( gmem_Moveable or gmem_Zeroinit ,
                                Bitmap_Info^.bmiHeader.biSizeImage );
    Bits_Byte_Size := Bitmap_Info^.bmiHeader.biSizeImage;
    Get_Bitmap_Data;
    DC_Handle := CreateDC( 'Display' , nil , nil , nil );
    Bits_Ptr := GlobalLock( Bits_Handle );
    New_Bitmap_Handle :=
    CreateDIBitmap( DC_Handle , Bitmap_Info^.bmiHeader ,
                    cbm_Init , Bits_Ptr , Bitmap_Info^ , 0 );
    DeleteDC( DC_Handle );
    GlobalUnlock( Bits_Handle );
    GlobalFree( Bits_Handle );
    FreeMem( Bitmap_Info , Size );
    if New_Bitmap_Handle <> 0 then
    begin
      if Bitmap_Handle <> 0 then DeleteObject( Bitmap_Handle );
      Bitmap_Handle := New_Bitmap_Handle;
      Width := New_Pixel_Width;
      Height := New_Pixel_Height;
    end
    else
    begin
      Open_DIB := false;
      Error_Status := -4;
    end;
  end
  else
  begin
    Open_DIB := false;
    Error_Status := -3;
  end;
end;

{ This is an OOP return of the error variable }
function File_BitMap.Get_Error_Status : Integer;
begin
  Get_Error_Status := Error_Status;
end;

{ This is an OOP return of the dimensions of the DIB }
procedure File_BitMap.Get_DIB_Dimensions( var The_Width  ,
                                              The_Height   : Longint );
begin
  The_Width := Width;
  The_Height := Height;
end;

end.